home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / PowerMacOberon feb96 / Source / ClipFrames.Mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1994-07-11  |  12.7 KB  |  297 lines  |  [.Ob./.Ob4]
  1. Syntax10.Scn.Fnt
  2. MODULE ClipFrames; (* J. Templ, 30.10.90/28.6.91 *)
  3.     (* ClipFrames.Frame provides basic drawing operations clipped on the frame borders.
  4.         all drawing and mouse coordinates are relative to the origin x0, y0, which is relative to the
  5.         top left corner of the frame. Capital letter coordinates always denote screen coordinates.
  6.         In addition, ClipFrames contains two other useful frame classes, one for printing, and one
  7.         for finding the bounding box*)
  8.     IMPORT
  9.         Oberon, Input, Display, Display1, Fonts, MenuViewers, TextFrames, GraphicOps, Texts, Printer;
  10.     TYPE
  11.         Frame* = POINTER TO FrameDesc;
  12.         FrameDesc* = RECORD (Display.FrameDesc)
  13.             col*, x0*, y0*, scale*: INTEGER;
  14.             ext*: Frame;
  15.         END ;
  16.         PrintFrame* = POINTER TO PrintFrameDesc;
  17.         PrintFrameDesc* = RECORD
  18.             (FrameDesc)
  19.         END ;
  20.         BalloonFrame* = POINTER TO BalloonFrameDesc;    (* inspired by B. Stamm *)
  21.         BalloonFrameDesc* = RECORD
  22.             (FrameDesc)
  23.         END ;
  24.         Lclip, Rclip, Bclip, Tclip: INTEGER;    (* current clipping rectangle *)
  25.     PROCEDURE Clip(F: Frame);
  26.     BEGIN
  27.         Lclip := F.X; Rclip := F.X + F.W; Bclip := F.Y; Tclip := F.Y + F.H
  28.     END Clip;
  29.     PROCEDURE Intersect(F: Frame; VAR X, Y, W, H: INTEGER): BOOLEAN;
  30.         VAR t: INTEGER;
  31.     BEGIN
  32.         t := X + W;
  33.         IF F.X > X THEN X := F.X END;
  34.         IF F.X + F.W < t THEN W := F.X + F.W - X ELSE W := t - X END;
  35.         IF W <= 0 THEN RETURN FALSE END;
  36.         t := Y + H;
  37.         IF F.Y > Y THEN Y := F.Y END;
  38.         IF F.Y + F.H < t THEN H := F.Y + F.H - Y ELSE H := t - Y END;
  39.         RETURN H > 0
  40.     END Intersect;
  41.     PROCEDURE MinMax(x, y: INTEGER; VAR min, max: INTEGER);
  42.     BEGIN IF x < y THEN min := x; max := y ELSE min := y; max := x END
  43.     END MinMax;
  44.     PROCEDURE Update (F: Frame; x, y, w, h: INTEGER);
  45.     BEGIN x := x + F.x0; y := y + F.y0;
  46.         IF x < F.X THEN F.W := F.W + F.X - x; F.X := x END ;
  47.         IF x + w > F.X + F.W THEN F.W := x + w - F.X END ;
  48.         IF y < F.Y THEN F.H := F.H + F.Y - y; F.Y := y END ;
  49.         IF y + h > F.Y + F.H THEN F.H := y + h - F.Y END
  50.     END Update;
  51. (* ----------------- coordinate conversion methods ------------------ *)
  52.     PROCEDURE (F: Frame) CX*(x: INTEGER): INTEGER;
  53.     BEGIN RETURN F.X + (F.x0 + x) DIV F.scale
  54.     END CX;
  55.     PROCEDURE (F: Frame) CY*(y: INTEGER): INTEGER;
  56.     BEGIN RETURN F.Y + F.H + (F.y0 + y) DIV F.scale
  57.     END CY;
  58.     PROCEDURE (F: Frame) Cx*(X: INTEGER): INTEGER;
  59.     BEGIN RETURN (X - F.X) * F.scale - F.x0
  60.     END Cx;
  61.     PROCEDURE (F: Frame) Cy*(Y: INTEGER): INTEGER;
  62.     BEGIN RETURN (Y - F.Y - F.H) * F.scale - F.y0
  63.     END Cy;
  64. (* ----------------- screen drawing methods ------------------ *)
  65.     PROCEDURE (F: Frame) DrawLine*(x1, y1, x2, y2, col, mode: INTEGER);
  66.     BEGIN
  67.         GraphicOps.Line(F, F.CX(x1), F.CY(y1), F.CX(x2), F.CY(y2), 1, Display1.ThisPattern(col), col)
  68.     END DrawLine;
  69.     PROCEDURE (F: Frame) DrawRect*(x, y, w, h, col, mode: INTEGER);
  70.     BEGIN
  71.         F.DrawLine(x,    y, x+w,    y, col, mode);
  72.         F.DrawLine(x+w,    y, x+w,    y+h, col, mode);
  73.         F.DrawLine(x,    y+h, x+w,    y+h, col, mode);
  74.         F.DrawLine(x,    y, x,    y+h, col, mode);
  75.         IF F.scale = 1 THEN
  76.             F.DrawLine(x,    y+1, x+w,    y+1, col, mode);
  77.             F.DrawLine(x,    y+2, x+w,    y+2, col, mode);
  78.             F.DrawLine(x+w-1,    y, x+w-1,    y+h, col, mode);
  79.             F.DrawLine(x+w-2,    y, x+w-2,    y+h, col, mode);
  80.             F.DrawLine(x,    y+h-1, x+w,    y+h-1, col, mode);
  81.             F.DrawLine(x,    y+h-2, x+w,    y+h-2, col, mode);
  82.             F.DrawLine(x+1,    y, x+1,    y+h, col, mode);
  83.             F.DrawLine(x+2,    y, x+2,    y+h, col, mode);
  84.         END
  85.     END DrawRect;
  86.     PROCEDURE ClippedDot4(x1, x2, y1, y2, col, mode: INTEGER);
  87.     BEGIN
  88.         IF (Lclip <= x1) & (x1 < Rclip) THEN
  89.             IF (Bclip <= y1) & (y1 < Tclip) THEN Display.ReplConst(col, x1, y1, 1, 1, mode) END;
  90.             IF (Bclip <= y2) & (y2 < Tclip) THEN Display.ReplConst(col, x1, y2, 1, 1, mode) END
  91.         END;
  92.         IF (Lclip <= x2) & (x2 < Rclip) THEN
  93.             IF (Bclip <= y1) & (y1 < Tclip) THEN Display.ReplConst(col, x2, y1, 1, 1, mode) END;
  94.             IF (Bclip <= y2) & (y2 < Tclip) THEN Display.ReplConst(col, x2, y2, 1, 1, mode) END
  95.         END
  96.     END ClippedDot4;
  97.     PROCEDURE (F: Frame) DrawCircle*(x, y, r, col, mode: INTEGER);
  98.         VAR x1, y1, d, dx, dy: INTEGER;
  99.     BEGIN
  100.         Clip(F);
  101.         x := F.CX(x); y := F.CY(y); r := r DIV F.scale;
  102.         x1 := r; y1 := 0; dx := 8*(x1-1); dy := 8*y1+4; d := 1-4*r;
  103.         WHILE x1 > y1 DO
  104.             ClippedDot4(x-x1-1, x+x1, y-y1-1, y+y1, col, mode);
  105.             ClippedDot4(x-y1-1, x+y1, y-x1-1, y+x1, col, mode);
  106.             INC(d, dy); INC(dy, 8); INC(y1);
  107.             IF d >= 0 THEN DEC(d, dx); DEC(dx, 8); DEC(x1) END
  108.         END;
  109.         IF x1 = y1 THEN ClippedDot4(x-x1-1, x+x1, y-y1-1, y+y1, col, mode) END
  110.     END DrawCircle;
  111.     PROCEDURE (F: Frame) DrawEllipse*(x, y, a, b, col, mode: INTEGER);
  112.         VAR
  113.             x1, y1: INTEGER;
  114.             d, dx, dy, x2, y2, a1, a2, a8, b1, b2, b8: LONGINT;
  115.     BEGIN
  116.         Clip(F);
  117.         x := F.CX(x); y := F.CY(y);
  118.         IF (Lclip<=x+a) OR (x-a<=Rclip) OR (Bclip<=y+b) OR (y-b<=Tclip) THEN (* ellipse may be visible *)
  119.             a1 := a; a2 := a1*a1; a8 := 8*a2; b1 := b; b2 := b1*b1; b8 := 8*b2;
  120.             x1 := a; y1 := 0; x2 := a1*b2; y2 := 0; dx := b8*(a1-1); dy := 4*a2; d := b2*(1- 4*a1);
  121.             WHILE y2 < x2 DO
  122.                 ClippedDot4(x-x1-1, x+x1, y-y1-1, y+y1, col, mode);
  123.                 INC(d, dy); INC(dy, a8); INC(y1); INC(y2, a2);
  124.                 IF d >= 0 THEN DEC(d, dx); DEC(dx, b8); DEC(x1); DEC(x2, b2) END
  125.             END;
  126.             INC(d, 4*(x2+y2)-b2+a2);
  127.             WHILE x1 >= 0 DO
  128.                 ClippedDot4(x-x1-1, x+x1, y-y1-1, y+y1, col, mode);
  129.                 DEC(d, dx); DEC(dx, b8); DEC(x1);
  130.                 IF d < 0 THEN INC(d, dy); INC(dy, a8); INC(y1) END
  131.             END
  132.         END
  133.     END DrawEllipse;
  134.     PROCEDURE (F: Frame) DrawString*(x, y: INTEGER; s: ARRAY OF CHAR; font: Fonts.Font; col, mode: INTEGER);
  135.         VAR ch: CHAR; pat: LONGINT; i, dx, chx, chy, chw, chh, chL, chB, chLOld, chBOld, chwOld, chhOld: INTEGER;
  136.     BEGIN
  137.         x := F.CX(x); y := F.CY(y);
  138.         ch := s[0]; i := 0;
  139.         WHILE ch # 0X DO
  140.             Display.GetChar(font.raster, ch, dx, chx, chy, chw, chh, pat);
  141.             chL := x+chx; chB := y+chy;
  142.             chLOld := chL; chBOld := chB; chwOld := chw; chhOld := chh;
  143.             IF Intersect(F, chL, chB, chw, chh) THEN
  144.                 IF (chw = chwOld) & (chh = chhOld) THEN
  145.                     Display.CopyPattern(col, pat, chL, chB, mode);
  146.                 ELSE
  147.                     Display.CopyBlock(chL, chB, chw, chh, chL-chLOld, -chhOld+chB-chBOld, Display.replace);
  148.                     Display.CopyPattern(col, pat, 0, -chhOld, mode);
  149.                     Display.CopyBlock(chL-chLOld, -chhOld+chB-chBOld, chw, chh, chL, chB, Display.replace)
  150.                 END
  151.             END ;
  152.             INC(x, dx * 4 DIV F.scale); INC(i); ch := s[i]
  153.         END
  154.     END DrawString;
  155.     PROCEDURE (F: Frame) FillRect* (x, y, w, h, col, mode: INTEGER);
  156.     BEGIN
  157.         x := F.CX(x); y := F.CY(y); w := w DIV F.scale; h := h DIV F.scale;
  158.         IF Intersect(F, x, y, w, h) THEN Display.ReplPattern(col, Display1.ThisPattern(col), x, y, w, h, mode) END
  159.     END FillRect;
  160.     PROCEDURE (F: Frame) FillCircle* (x, y, r, col, mode: INTEGER);
  161.     BEGIN
  162.         GraphicOps.Ellipse(F, F.CX(x), F.CY(y), r, r, 1, Display1.ThisPattern(col), col)
  163.     END FillCircle;
  164.     PROCEDURE (F: Frame) FillQuad* (x1, y1, x2, y2, x3, y3, x4, y4, col, mode: INTEGER);    (* by B. Stamm *)
  165.             TYPE    LineParms = RECORD x,y,d,dx,dy,inx,iny,drawX,drawY: INTEGER END;
  166.             VAR x,y,RHS2,RHS3: INTEGER; left,right: LineParms;
  167.             PROCEDURE InitLineParms(x1,y1,x2,y2: INTEGER; VAR p: LineParms);
  168.             BEGIN
  169.                 p.x := x1; p.dx := x2-x1; IF p.dx > 0 THEN p.inx := 1 ELSIF p.dx < 0 THEN p.inx := -1; p.dx := -p.dx ELSE p.inx := 0 END;
  170.                 p.y := y1; p.dy := y2-y1; IF p.dy > 0 THEN p.iny := 1 ELSIF p.dy < 0 THEN p.iny := -1; p.dy := -p.dy ELSE p.iny := 0 END;
  171.                 p.d := p.dy - p.dx; p.dx := 2*p.dx; p.dy := 2*p.dy;
  172.             END InitLineParms;
  173.             PROCEDURE LineStep(VAR p: LineParms);
  174.                 (* H = (d(x,y) := (2*x - 2*x1 + 1)*dy - (2*y - 2*y1 + 1)*dx < 0) *)
  175.             BEGIN
  176.                 WHILE p.d < 0 DO INC(p.x,p.inx); INC(p.d,p.dy) END;
  177.                 p.drawX := p.x; p.drawY := p.iny DIV 2 + p.y;
  178.                 DEC(p.d,p.dx); INC(p.y,p.iny);
  179.             END LineStep;
  180.     BEGIN (* Quadrangle *)
  181.     x1 := F.CX(x1); x2 := F.CX(x2); x3 := F.CX(x3); x4 := F.CX(x4);
  182.     y1 := F.CY(y1); y2 := F.CY(y2); y3 := F.CY(y3); y4 := F.CY(y4);
  183.         IF (y1>y2) OR (y1=y2) & (x1>x2) THEN x := x1; x1 := x2; x2 := x; y := y1; y1 := y2; y2 := y END;
  184.         IF (y2>y3) OR (y2=y3) & (x2>x3) THEN x := x2; x2 := x3; x3 := x; y := y2; y2 := y3; y3 := y END;
  185.         IF (y3>y4) OR (y3=y4) & (x3>x4) THEN x := x3; x3 := x4; x4 := x; y := y3; y3 := y4; y4 := y END;
  186.         IF (y1>y2) OR (y1=y2) & (x1>x2) THEN x := x1; x1 := x2; x2 := x; y := y1; y1 := y2; y2 := y END;
  187.         IF (y2>y3) OR (y2=y3) & (x2>x3) THEN x := x2; x2 := x3; x3 := x; y := y2; y2 := y3; y3 := y END;
  188.         IF (y1>y2) OR (y1=y2) & (x1>x2) THEN x := x1; x1 := x2; x2 := x; y := y1; y1 := y2; y2 := y END;
  189.         IF LONG(x2-x1)*LONG(y4-y1) > LONG(y2-y1)*LONG(x4-x1) THEN RHS2 := 2 ELSE RHS2 := 0 END;
  190.         IF LONG(x3-x1)*LONG(y4-y1) > LONG(y3-y1)*LONG(x4-x1) THEN RHS3 := 1 ELSE RHS3 := 0 END;
  191.         CASE RHS2 + RHS3 OF
  192.         | 0: InitLineParms(x1,y1,x2,y2,left); InitLineParms(x1,y1,x4,y4,right);
  193.         | 1: InitLineParms(x1,y1,x2,y2,left); InitLineParms(x1,y1,x3,y3,right);
  194.         | 2: InitLineParms(x1,y1,x3,y3,left); InitLineParms(x1,y1,x2,y2,right);
  195.         | 3: InitLineParms(x1,y1,x4,y4,left); InitLineParms(x1,y1,x2,y2,right);
  196.         END;
  197.         WHILE left.y # y2 DO
  198.             LineStep(left); LineStep(right);
  199.             F.DrawLine(F.Cx(left.drawX),F.Cy(left.drawY),F.Cx(right.drawX),F.Cy(left.drawY),col,mode)
  200.         END;
  201.         CASE RHS2 + RHS3 OF
  202.         | 0: InitLineParms(x2,y2,x3,y3,left);
  203.         | 1: InitLineParms(x2,y2,x4,y4,left);
  204.         | 2: InitLineParms(x2,y2,x4,y4,right);
  205.         | 3: InitLineParms(x2,y2,x3,y3,right);
  206.         END;
  207.         WHILE left.y # y3 DO
  208.             LineStep(left); LineStep(right);
  209.             F.DrawLine(F.Cx(left.drawX),F.Cy(left.drawY),F.Cx(right.drawX),F.Cy(left.drawY),col,mode)
  210.         END;
  211.         CASE RHS2 + RHS3 OF
  212.         | 0,2: InitLineParms(x3,y3,x4,y4,left);
  213.         | 1,3: InitLineParms(x3,y3,x4,y4,right);
  214.         END;
  215.         WHILE left.y # y4 DO
  216.             LineStep(left); LineStep(right);
  217.             F.DrawLine(F.Cx(left.drawX),F.Cy(left.drawY),F.Cx(right.drawX),F.Cy(left.drawY),col,mode)
  218.         END
  219.     END FillQuad;
  220. (* ----------------- printer drawing methods ------------------ *)
  221.     PROCEDURE (F: PrintFrame) DrawRect* (x, y, w, h, col, mode: INTEGER);
  222.     BEGIN
  223.         x := F.CX(x)-1; y := F.CY(y)-1;
  224.         Printer.ReplConst(x, y, w, 3);
  225.         Printer.ReplConst(x+w, y, 3, h+3);
  226.         Printer.ReplConst(x, y+h, w, 3);
  227.         Printer.ReplConst(x, y, 3, h);
  228.     END DrawRect;
  229.     PROCEDURE (F: PrintFrame) DrawLine* (x1, y1, x2, y2, col, mode: INTEGER);
  230.     BEGIN
  231.         x1 := F.CX(x1); y1 := F.CY(y1);
  232.         x2 := F.CX(x2); y2 := F.CY(y2);
  233.         Printer.Line(x1, y1, x2, y2)
  234.     END DrawLine;
  235.     PROCEDURE (F: PrintFrame) DrawCircle* (x, y, r, col, mode: INTEGER);
  236.     BEGIN Printer.Circle(F.CX(x), F.CY(y), r)
  237.     END DrawCircle;
  238.     PROCEDURE (F: PrintFrame) DrawEllipse* (x, y, a, b, col, mode: INTEGER);
  239.     BEGIN Printer.Ellipse(F.CX(x), F.CY(y), a, b)
  240.     END DrawEllipse;
  241.     PROCEDURE (F: PrintFrame) DrawString* (x, y: INTEGER; s: ARRAY OF CHAR; font: Fonts.Font; col, mode: INTEGER);
  242.     BEGIN
  243.         Printer.String(F.CX(x), F.CY(y), s, font.name)
  244.     END DrawString;
  245.     PROCEDURE (F: PrintFrame) FillRect* (x, y, w, h, col, mode: INTEGER);
  246.     BEGIN Printer.ReplPattern(F.CX(x), F.CY(y), w, h, col);
  247.     END FillRect;
  248.     PROCEDURE (F: PrintFrame) FillCircle* (x, y, r, col, mode: INTEGER);
  249.         VAR error: ARRAY 32 OF CHAR;
  250.     BEGIN error := "not yet implemented";
  251.         HALT(99)
  252.     END FillCircle;
  253. (* ----------------- methods for finding the bounding box------------------ *)
  254.     PROCEDURE (F: BalloonFrame) DrawRect* (x, y, w, h, col, mode: INTEGER);
  255.     BEGIN Update(F, x, y, w, h)
  256.     END DrawRect;
  257.     PROCEDURE (F: BalloonFrame) DrawLine* (x1, y1, x2, y2, col, mode: INTEGER);
  258.         VAR minx, miny, maxx, maxy: INTEGER;
  259.     BEGIN
  260.         MinMax(x1, x2, minx, maxx);
  261.         MinMax(y1, y2, miny, maxy);
  262.         Update(F, minx, miny, maxx - minx, maxy - miny)
  263.     END DrawLine;
  264.     PROCEDURE (F: BalloonFrame) DrawCircle* (x, y, r, col, mode: INTEGER);
  265.     BEGIN Update(F, x - r - 4 , y - r - 4, 2 * r + 4, 2 * r + 4)
  266.     END DrawCircle;
  267.     PROCEDURE (F: BalloonFrame) DrawEllipse* (x, y, a, b, col, mode: INTEGER);
  268.     BEGIN Update(F, x - a - 4, y - b - 4, 2 * a + 4, 2 * b + 4)
  269.     END DrawEllipse;
  270.     PROCEDURE (F: BalloonFrame) DrawString* (x, y: INTEGER; s: ARRAY OF CHAR; font: Fonts.Font; col, mode: INTEGER);
  271.         VAR i, w, dx, X, Y, W, H: INTEGER; p: LONGINT; ch: CHAR;
  272.     BEGIN
  273.         i := 0; w := 0; ch := s[0];
  274.         WHILE ch # 0X DO Display.GetChar(font.raster, ch, dx, X, Y, W, H, p); INC(w, dx * 4); INC(i); ch := s[i] END ;
  275.         Update(F, x, y, w, font.height*4)
  276.     END DrawString;
  277.     PROCEDURE (F: BalloonFrame) FillRect* (x, y, w, h, col, mode: INTEGER);
  278.     BEGIN Update(F, x, y, w, h)
  279.     END FillRect;
  280.     PROCEDURE (F: BalloonFrame) FillCircle* (x, y, r, col, mode: INTEGER);
  281.     BEGIN Update(F, x - r - 4 , y - r - 4, 2 * r + 4, 2 * r + 4)
  282.     END FillCircle;
  283.     PROCEDURE (F: BalloonFrame) FillQuad* (x1, y1, x2, y2, x3, y3, x4, y4, col, mode: INTEGER);
  284.     BEGIN
  285.         MinMax(x1, x2, x1, x2); MinMax(x2, x3, x2, x3); MinMax(x3, x4, x3, x4);
  286.         MinMax(x2, x3, x2, x3); MinMax(x1, x2, x1, x2);
  287.         MinMax(y1, y2, y1, y2); MinMax(y2, y3, y2, y3); MinMax(y3, y4, y3, y4);
  288.         MinMax(y2, y3, y2, y3); MinMax(y1, y2, y1, y2);
  289.         Update(F, x1, y1, x4 - x1, y4 - y1)
  290.     END FillQuad;
  291.     PROCEDURE InitBalloon*(F: BalloonFrame);
  292.     BEGIN F.scale := 1;
  293.         F.X := 10000; F.Y := 10000;
  294.         F.W := -20000; F.H := -20000
  295.     END InitBalloon;
  296. END ClipFrames.
  297.